home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tools / istls / ISTLS.MAC.f
Encoding:
Text File  |  1989-03-04  |  18.9 KB  |  611 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 3.1
  3. C---------------------------------------------------------
  4. C
  5. C  ISTLS  - Long name changer
  6. C
  7. C  Prompt the user for replacements for names more than 6
  8. C  characters long.  Output token stream contains replaced
  9. C  names.  A user-supplied candidate for a replacement will not
  10. C  be accepted if it is not a legal Fortran name or if it
  11. C  has already been used in the program.
  12. C
  13.         PROGRAM ISTLS
  14.  
  15. C---------------------------------------------------------
  16. C    TOOLPACK/1    Release: 2.4
  17. C---------------------------------------------------------
  18. C
  19. C  TKLAST = LAST TOKEN NUMBER
  20. C
  21.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  22.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  23.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  24.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  25.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  26.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  27.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  28.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  29.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  30.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  31.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  32.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  33.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  34.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  35.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  36.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  37.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  38.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  39.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  40.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  41.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  42.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  43.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  44.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  45.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  46.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  47.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  48.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  49.  
  50. C  COMMON BLOCK NTABLE - Table of names used in the program.
  51.  
  52.         COMMON/NTABLE/ NAMCNT,NAMTAB
  53.  
  54. C  NAMCNT IS THE NUMBER OF NAMES IN THE TABLE
  55. C  NAMTAB IS THE TABLE OF NAMES AS IST STRINGS
  56.  
  57.         INTEGER NAMCNT
  58.         INTEGER NAMTAB(32,2000)
  59.  
  60. C  CTABLE - COMMON Block containing the tables for converting
  61. C  long names to short.
  62.  
  63.  
  64.         COMMON /CTABLE/ LSTORE,SSTORE
  65.         COMMON /CTABLN/ NRNAME,MAXNAM
  66.  
  67. C       LSTORE contains the long names.
  68. C       SSTORE contains the short names.
  69. C       Long and short names with the same array index are paired.
  70. C       NRNAME is the number of pairs.
  71. C       MAXNAM is the maximum number of pairs.
  72.  
  73.         CHARACTER*31 LSTORE(1000)
  74.         CHARACTER*6 SSTORE(1000)
  75.         INTEGER NRNAME,MAXNAM
  76.  
  77.         INTEGER TKNPTH(81),CMTPTH(81)
  78.         INTEGER TKNOUT(81),CMTOUT(81)
  79.         INTEGER CONLST(81),LOGPTH(81)
  80.         INTEGER STRING(1322),NEWTXT(134)
  81.         INTEGER NAME1(134),NAME2(134)
  82.         INTEGER TOKTYP,LENGTH,STATUS,IODTKN,IODCMT,
  83.      +          IODTKO,IODCMO,IODCON,IODLOG,LEN,LENS,IJUNK,
  84.      +          TOKNUM,DESCI,DESCO
  85.         INTEGER I,J
  86.  
  87.         CHARACTER*31 LTEMP
  88.         CHARACTER*6  STEMP
  89.         LOGICAL COMNT,FIRST
  90.         INTEGER LNAME(32)
  91.         INTEGER SNAME(7)
  92.  
  93.         INTEGER GETARG,OPEN,CREATE,ZSTATE,ZGTCMD,ZCCTOI,ZLOWER,ZTKGTI,
  94.      +          ZTKPTI
  95.         EXTERNAL ZINIT,GETARG,OPEN,ERROR,SCOPY,ZGTCMD,ZPTMES,
  96.      +           RENAME,CREATE,SEEK,ZSTATE,ZQUIT,REMARK,CHKSTR,
  97.      +           ZCCTOI,CLOSE,REMOVE,ZLOWER,ZCHOUT,ZPTINT,PUTLIN,
  98.      +           ZTKGTI,ZTKPTI,ZGETTK,ZPUTTK
  99.  
  100.         SAVE
  101.  
  102.         NRNAME=0
  103.         MAXNAM=1000
  104.  
  105.         CALL ZINIT
  106.  
  107. C Read paths from IST.CMD
  108.  
  109.         IF (GETARG(1,TKNPTH,81).EQ.-100) CALL NAMES(1,TKNPTH)
  110.         IF (GETARG(2,CMTPTH,81).EQ.-100) CALL NAMES(2,CMTPTH)
  111.         IF (GETARG(3,TKNOUT,81).EQ.-100) CALL NAMES(3,TKNOUT)
  112.         IF (GETARG(4,CMTOUT,81).EQ.-100) CALL NAMES(4,CMTOUT)
  113.         IF (GETARG(5,CONLST,81).EQ.-100) CALL NAMES(5,CONLST)
  114.         IF (GETARG(6,LOGPTH,81).EQ.-100) CALL NAMES(6,LOGPTH)
  115.  
  116. C Open required files
  117.  
  118.         IODTKN=OPEN(TKNPTH,0)
  119.         IF (IODTKN.EQ.-1) CALL ERROR('Can''t Open Token/In Path.')
  120.         IODCMT=OPEN(CMTPTH,0)
  121.         IF (IODCMT.EQ.-1) CALL ERROR('Can''t Open Comment/In Path.')
  122.         DESCI = ZTKGTI(1, IODTKN, IODCMT)
  123.         IF (DESCI.LE.0) CALL ERROR('Can''t Open In Path.')
  124.  
  125.         IODTKO=CREATE(TKNOUT,1)
  126.         IF (IODTKO.EQ.-1) CALL ERROR('Can''t Open Token/Out Path.')
  127.         IODCMO=CREATE(CMTOUT,1)
  128.         IF (IODCMO.EQ.-1) CALL ERROR('Can''t Open Comment/Out Path.')
  129.         DESCO = ZTKPTI(1, IODTKO, IODCMO)
  130.         IF (DESCO.LE.0) CALL ERROR('Can''t Open Out Path.')
  131.  
  132.         IF (ZSTATE(CONLST).EQ.-2) THEN
  133.            IODCON=OPEN(CONLST,0)
  134.            IF (IODCON.EQ.-1)
  135.      +        CALL ERROR('Can''t Open Conversion File.')
  136.         ELSE
  137.            IODCON=CREATE(CONLST,2)
  138.            IF (IODCON.EQ.-1)
  139.      +        CALL ERROR('Can''t Create Conversion File.')
  140.         ENDIF
  141.         IODLOG=CREATE(LOGPTH,1)
  142.         IF (IODLOG.EQ.-1) CALL ERROR('Can''t Create Log Path.')
  143.         CALL ZMESS('ISTLS - Name Conversion Log.',IODLOG)
  144.         CALL ZMESS(' .',IODLOG)
  145.         TOKNUM = 0
  146.         FIRST = .TRUE.
  147.         COMNT = .FALSE.
  148.  
  149. C First pass through token stream.  Construct table of names
  150. C used in program.
  151.  
  152.         NAMCNT = 0
  153. 20      CONTINUE
  154.         CALL ZGETTK(TOKTYP,LENGTH,STRING,DESCI,STATUS)
  155.         IF(STATUS.EQ.-1.OR.STATUS.EQ.-100) CALL ERROR(
  156.      +'Error In Reading Token Stream - First Pass.')
  157.         IF(TOKTYP.EQ.TZEOF) GO TO 30
  158.         IF(TOKTYP.EQ.TNAME) THEN
  159.            IF(LENGTH.GT.31) THEN
  160.               CALL ZCHOUT('Name .',2)
  161.               CALL PUTLIN(STRING,2)
  162.               CALL ZMESS(' Truncated to 31 Characters.',2)
  163.            ENDIF
  164.            NAMCNT = NAMCNT + 1
  165. C Convert STRING to lower case for storage.
  166. C Truncate to 31 characters if necessary.
  167.            DO 400 I = 1, 31
  168.               IF(STRING(I) .EQ. 129) GO TO 410
  169.               STRING(I) = ZLOWER(STRING(I))
  170. 400        CONTINUE
  171.            STRING(32) = 129
  172. 410        CALL SCOPY(STRING,1,NAMTAB(1,NAMCNT),1)
  173.         ENDIF
  174.         GO TO 20
  175.  
  176. C Rewind input files in preparation for second pass.
  177. 30      CALL SEEK(0,IODTKN)
  178.         CALL SEEK(0,IODCMT)
  179.         CALL ZTKGTQ(DESCI)
  180.         DESCI = ZTKGTI(1, IODTKN, IODCMT)
  181.         IF (DESCI.LE.0) CALL ERROR('Can''t Reopen In Path.')
  182.  
  183. C Read conversion file and store long-short pairs.
  184. 100     CONTINUE
  185.         LEN = ZGTCMD(NAME1,IODCON)
  186.         IF(LEN.EQ.-100)GO TO 10
  187.         LENS = ZGTCMD(NAME2,IODCON)
  188.         IF(LENS.EQ.-100) THEN
  189.            CALL REMARK('Unexpected End-Of-File In Conversion File.')
  190.            CALL ZCHOUT('Replacement For Name ".', 2)
  191.            CALL PUTLIN(NAME1,2)
  192.            CALL ZMESS('" Not In File.', 2)
  193.            GO TO 10
  194.         ENDIF
  195.         CALL CHKSTR(NAME1,LEN,NAME2)
  196.         GO TO 100
  197.  
  198. C Second pass through token stream.  Call RENAME for names longer
  199. C than 6 characters.
  200.  
  201. 10      CONTINUE
  202.         CALL ZGETTK(TOKTYP,LENGTH,STRING,DESCI,STATUS)
  203.         IF(STATUS.EQ.-1.OR.STATUS.EQ.-100) CALL ERROR(
  204.      +'Error In Reading Token Stream - Second Pass.')
  205.  
  206. C Count the token number for the Log file.
  207.         IF(FIRST) THEN
  208.            FIRST = .FALSE.
  209.            TOKNUM = TOKNUM + 1
  210.            IF(TOKTYP.EQ.TCMMNT) COMNT = .TRUE.
  211.         ELSE
  212.            IF(TOKTYP.EQ.TCMMNT.AND. .NOT. COMNT) THEN
  213.               COMNT = .TRUE.
  214.               TOKNUM = TOKNUM + 1
  215.            ENDIF
  216.            IF(TOKTYP.NE.TCMMNT) THEN
  217.               COMNT = .FALSE.
  218.               TOKNUM = TOKNUM + 1
  219.            ENDIF
  220.         ENDIF
  221.  
  222.         IF(TOKTYP.EQ.TNAME.AND.LENGTH.GT.6) THEN
  223.            CALL RENAME(STRING,LENGTH,NEWTXT)
  224.            CALL ZCHOUT('Token Number .',IODLOG)
  225.            CALL ZPTINT(TOKNUM,1,IODLOG)
  226.            CALL ZCHOUT(': .',IODLOG)
  227.            CALL PUTLIN(STRING,IODLOG)
  228.            CALL ZCHOUT(' Replaced By .',IODLOG)
  229.            CALL ZPTMES(NEWTXT,IODLOG)
  230.            CALL SCOPY(NEWTXT,1,STRING,1)
  231.         ENDIF
  232.  
  233.         CALL ZPUTTK(TOKTYP,LENGTH,STRING,DESCO)
  234.  
  235.         IF(TOKTYP.EQ.TZEOF) THEN
  236.  
  237. C Recreate the conversion file from conversion tables.
  238. C and terminate.
  239.  
  240.           CALL CLOSE(IODCON)
  241.           CALL REMOVE(CONLST)
  242.           IODCON = CREATE(CONLST,1)
  243.           DO 200 I=1,NRNAME
  244.              LTEMP = LSTORE(I)
  245.              DO 210 J=1,31
  246.                 IF(LTEMP(J:J) .EQ. ' ')THEN
  247.                   LNAME(J) = 129
  248.                   GO TO 220
  249.                 ENDIF
  250.                 IJUNK = ZCCTOI(LTEMP(J:J), LNAME(J))
  251. 210          CONTINUE
  252.  
  253.           LNAME(32) = 129
  254.  
  255. 220       CALL ZPTMES(LNAME,IODCON)
  256.  
  257.            STEMP = SSTORE(I)
  258.            DO 310 J=1,6
  259.               IF(STEMP(J:J) .EQ. ' ')THEN
  260.                 SNAME(J) = 129
  261.                 GO TO 320
  262.               ENDIF
  263.               IJUNK = ZCCTOI(STEMP(J:J), SNAME(J))
  264. 310        CONTINUE
  265.  
  266.           SNAME(7) = 129
  267.  
  268. 320       CALL ZPTMES(SNAME,IODCON)
  269.  
  270. 200       CONTINUE
  271.  
  272.           CALL ZMESS('[ISTLS Normal Termination].', 2)
  273.           CALL ZQUIT(-2)
  274.  
  275.         ELSE
  276.            GO TO 10
  277.         ENDIF
  278.  
  279.         END
  280. C  ----------------------------------------------------------
  281. C       C H K S T R - Check names from conversion file and
  282. C                     store in conversion tables.
  283.  
  284.  
  285.         SUBROUTINE CHKSTR(NAME1,LEN,NAME2)
  286.  
  287. C  COMMON BLOCK NTABLE - Table of names used in the program.
  288.  
  289.         COMMON/NTABLE/ NAMCNT,NAMTAB
  290.  
  291. C  NAMCNT IS THE NUMBER OF NAMES IN THE TABLE
  292. C  NAMTAB IS THE TABLE OF NAMES AS IST STRINGS
  293.  
  294.         INTEGER NAMCNT
  295.         INTEGER NAMTAB(32,2000)
  296.  
  297. C  CTABLE - COMMON Block containing the tables for converting
  298. C  long names to short.
  299.  
  300.  
  301.         COMMON /CTABLE/ LSTORE,SSTORE
  302.         COMMON /CTABLN/ NRNAME,MAXNAM
  303.  
  304. C       LSTORE contains the long names.
  305. C       SSTORE contains the short names.
  306. C       Long and short names with the same array index are paired.
  307. C       NRNAME is the number of pairs.
  308. C       MAXNAM is the maximum number of pairs.
  309.  
  310.         CHARACTER*31 LSTORE(1000)
  311.         CHARACTER*6 SSTORE(1000)
  312.         INTEGER NRNAME,MAXNAM
  313.  
  314.         INTEGER NAME1(*), NAME2(*)
  315.         INTEGER TNAME2(7)
  316.         INTEGER LEN, I, NEWLEN
  317.         CHARACTER CJUNK
  318.         CHARACTER*31 LTEMP
  319.         CHARACTER*6 STEMP
  320.  
  321.         INTEGER LEGAL, LENGTH, ZLOWER
  322.         CHARACTER ZCITOC
  323.         EXTERNAL ZCITOC, SCOPY, LEGAL, LENGTH, ZLOWER
  324.  
  325.         SAVE
  326.  
  327. C Convert long name to lower-case F77 characters
  328. C for comparing and storage.
  329.  
  330.         DO 20 I=1,LEN
  331.            CJUNK = ZCITOC(ZLOWER(NAME1(I)), LTEMP(I:I))
  332. 20      CONTINUE
  333.  
  334. C Pad with blanks
  335.         DO 100 I=LEN+1,31
  336.            LTEMP(I:I) = ' '
  337. 100     CONTINUE
  338.  
  339. C Compare the input long name with the stored long names.
  340. C If long name found already stored, output a warning and
  341. C do not store the second pair.
  342.  
  343.         DO 30 I=1,NRNAME
  344.            IF(LTEMP .EQ. LSTORE(I)) GO TO 40
  345. 30      CONTINUE
  346.  
  347. C  Check whether the proposed replacement is a legal Fortran name.
  348. C  and whether it is already used in the program.  Even used
  349. C  replacements will be accepted if the associated long name
  350. C  is not used.  This permits a conversion file to contain conversions
  351. C  for many programs so long as conflicts do not arise.
  352.  
  353.         NEWLEN = LENGTH(NAME2)
  354.         IF (LEGAL(NAME1,NAME2,NEWLEN) .EQ. -3) THEN
  355.         CALL ZCHOUT('      Name ".', 2)
  356.         CALL PUTLIN(NAME2, 2)
  357.         CALL ZMESS('" in conversion file creates a conflict.', 2)
  358.         CALL ZMESS('----Not Used.',2)
  359.         RETURN
  360.         ENDIF
  361.  
  362. C  Proposed replacement accepted.  Add to table of used names
  363. C  (in lower case) and to replacement tables (in original case).
  364.  
  365.         NRNAME = NRNAME + 1
  366.         LSTORE(NRNAME) = LTEMP
  367.         NAMCNT = NAMCNT + 1
  368.            DO 400 I = 1, 132-4
  369.               IF(NAME2(I) .EQ. 129) GO TO 410
  370.               TNAME2(I) = ZLOWER(NAME2(I))
  371. 400        CONTINUE
  372. 410     TNAME2(I) = 129
  373.         CALL SCOPY(TNAME2,1,NAMTAB(1,NAMCNT),1)
  374.  
  375.         NEWLEN = LENGTH(NAME2)
  376.         DO 50 I=1,NEWLEN
  377.            CJUNK = ZCITOC(NAME2(I), STEMP(I:I))
  378. 50      CONTINUE
  379.  
  380. C  Pad With Blanks
  381.         DO 90 I=NEWLEN+1,6
  382.            STEMP(I:I) = ' '
  383. 90      CONTINUE
  384.  
  385.         SSTORE(NRNAME) = STEMP
  386.  
  387.         RETURN
  388.  
  389. 40      CALL ZMESS('Name '//LTEMP//'.', 2)
  390.         CALL ZMESS('      already in Replacement Table.', 2)
  391.         CALL ZCHOUT('      Replacement Name .', 2)
  392.         CALL PUTLIN(NAME2, 2)
  393.         CALL ZMESS(' ignored.', 2)
  394.  
  395.         RETURN
  396.         END
  397. C --------------------------------------------------------------
  398. C       L E G A L - Check whether a name is a legal Fortran name
  399. C                   and whether it already appears in table of
  400. C                   names used in program.  Even if it is already
  401. C                   used, a name is acceptable if its associated
  402. C                   long name is not used in the program.
  403. C                   Return yes if acceptable, no otherwise.
  404.  
  405.         INTEGER FUNCTION LEGAL(LNAME,SNAME,LENS)
  406.  
  407. C  COMMON BLOCK NTABLE - Table of names used in the program.
  408.  
  409.         COMMON/NTABLE/ NAMCNT,NAMTAB
  410.  
  411. C  NAMCNT IS THE NUMBER OF NAMES IN THE TABLE
  412. C  NAMTAB IS THE TABLE OF NAMES AS IST STRINGS
  413.  
  414.         INTEGER NAMCNT
  415.         INTEGER NAMTAB(32,2000)
  416.  
  417.         INTEGER LNAME(*),SNAME(*)
  418.         INTEGER TSNAME(134),TLNAME(134)
  419.         INTEGER LENS
  420.         INTEGER I,J,K
  421.         LOGICAL FLAG1, FLAG2
  422.         INTEGER EQUAL, ZLOWER
  423.         EXTERNAL EQUAL, ZMESS, ZLOWER, ZLEGAL
  424.  
  425.         SAVE
  426.  
  427.         LEGAL = -3
  428.  
  429.       CALL ZLEGAL(SNAME, FLAG1, FLAG2)
  430.       IF(.NOT. FLAG1) THEN
  431.         CALL ZMESS('Illegal variable name.', 2)
  432.         RETURN
  433.       ENDIF
  434.  
  435. C  Check to see if the proposed replacement is already used.
  436. C  Use a lower case copy of SNAME for comparison.
  437.  
  438.         DO 300 I = 1, 132-4
  439.            IF(SNAME(I) .EQ. 129) GO TO 310
  440.            TSNAME(I) = ZLOWER(SNAME(I))
  441. 300     CONTINUE
  442.  
  443. 310     TSNAME(I) = 129
  444.         DO 120 I=1,NAMCNT
  445.            IF(EQUAL(TSNAME,NAMTAB(1,I)).EQ.-2) THEN
  446.                 DO 200 J=1,NAMCNT
  447. C Long name to lower case for comparison.
  448.         DO 400 K = 1, 132-4
  449.            IF(LNAME(K) .EQ. 129) GO TO 410
  450.            TLNAME(K) = ZLOWER(LNAME(K))
  451. 400     CONTINUE
  452.  
  453. 410     TLNAME(K) = 129
  454.                 IF(EQUAL(TLNAME,NAMTAB(1,J)).EQ.-2) THEN
  455.                 CALL ZMESS('Replacement Name Already Used.',2)
  456.                 CALL ZMESS('in the Program.',2)
  457.                 CALL ZMESS('---------------------------------.',2)
  458.                 RETURN
  459.                 ENDIF
  460. 200             CONTINUE
  461.            ENDIF
  462. 120     CONTINUE
  463.  
  464. C SNAME passes all tests.
  465.  
  466.         LEGAL = -2
  467.         END
  468. C ----------------------------------------------------------------------
  469. C
  470. C       N A M E S  -  Input a pathname after prompting
  471. C
  472.         SUBROUTINE NAMES(NUMB,PATH)
  473.         INTEGER NUMB,PATH(*)
  474.  
  475.         INTEGER JUNK,PROMPT(21,6)
  476.  
  477.         INTEGER ZGTCMD
  478.         EXTERNAL ZGTCMD,ZPRMPT
  479.  
  480.         DATA (PROMPT(I,1),I=1,20)/
  481.      +        84,111,107,101,110,32,115,116,114,101,
  482.      +        97,109,32,40,105,110,41,58,32,129/,
  483.      +       (PROMPT(I,2),I=1,20)/
  484.      +        67,111,109,109,101,110,116,32,102,105,
  485.      +        108,101,32,40,105,110,41,58,32,129/,
  486.      +       (PROMPT(I,3),I=1,21)/
  487.      +        84,111,107,101,110,32,115,116,114,101,
  488.      +        97,109,32,40,111,117,116,41,58,
  489.      +        32,129/,
  490.      +       (PROMPT(I,4),I=1,21)/
  491.      +        67,111,109,109,101,110,116,32,102,105,
  492.      +        108,101,32,40,111,117,116,41,58,
  493.      +        32,129/
  494.      +       (PROMPT(I,5),I=1,18)/
  495.      +        67,111,110,118,101,114,115,105,111,110,
  496.      +        32,102,105,108,101,58,
  497.      +        32,129/
  498.         DATA (PROMPT(I,6),I=1,11)/
  499.      +        76,111,103,32,102,105,108,101,58,
  500.      +        32,129/
  501.  
  502.         CALL ZPRMPT(PROMPT(1,NUMB))
  503.         JUNK=ZGTCMD(PATH,0)
  504.  
  505.         END
  506. C  ----------------------------------------------------------
  507. C       R E N A M E - Obtain and manage replacements for long names
  508. C
  509.         SUBROUTINE RENAME(NAME1,LENT,NAME2)
  510.  
  511. C  COMMON BLOCK NTABLE - Table of names used in the program.
  512.  
  513.         COMMON/NTABLE/ NAMCNT,NAMTAB
  514.  
  515. C  NAMCNT IS THE NUMBER OF NAMES IN THE TABLE
  516. C  NAMTAB IS THE TABLE OF NAMES AS IST STRINGS
  517.  
  518.         INTEGER NAMCNT
  519.         INTEGER NAMTAB(32,2000)
  520.  
  521. C  CTABLE - COMMON Block containing the tables for converting
  522. C  long names to short.
  523.  
  524.  
  525.         COMMON /CTABLE/ LSTORE,SSTORE
  526.         COMMON /CTABLN/ NRNAME,MAXNAM
  527.  
  528. C       LSTORE contains the long names.
  529. C       SSTORE contains the short names.
  530. C       Long and short names with the same array index are paired.
  531. C       NRNAME is the number of pairs.
  532. C       MAXNAM is the maximum number of pairs.
  533.  
  534.         CHARACTER*31 LSTORE(1000)
  535.         CHARACTER*6 SSTORE(1000)
  536.         INTEGER NRNAME,MAXNAM
  537.  
  538.         INTEGER NAME1(*), NAME2(*)
  539.         INTEGER TNAME2(7)
  540.         INTEGER LENT, I, NEWLEN, J
  541.         INTEGER IJUNK
  542.         CHARACTER CJUNK
  543.         CHARACTER*31 LTEMP
  544.         CHARACTER*6 STEMP
  545.  
  546.         INTEGER ZGTCMD, ZCCTOI, LEGAL, ZLOWER
  547.         CHARACTER ZCITOC
  548.         EXTERNAL ZGTCMD, ZCCTOI, ZCITOC, SCOPY, LEGAL, ZLOWER
  549.  
  550.         SAVE
  551.  
  552. C Convert long name to lower case F77 characters
  553. C for comparing and storage.
  554.  
  555.         DO 20 I=1,LENT
  556.            LTEMP(I:I) = ZCITOC(ZLOWER(NAME1(I)), CJUNK)
  557. 20      CONTINUE
  558.  
  559. C Pad with blanks
  560.         LTEMP(LENT+1:) = ' '
  561.  
  562. C Compare the input long name with the stored long names.
  563. C If long name found already stored, output its short replacement;
  564. C otherwise request a replacement and put long name and replacement
  565. C into the tables.
  566.  
  567.         DO 30 I=1,NRNAME
  568.            IF(LTEMP .EQ. LSTORE(I)) THEN
  569.              DO 70 J=1,6
  570.                IF(SSTORE(I)(J:J) .EQ. ' ') GO TO 72
  571.                NAME2(J) = ZCCTOI(SSTORE(I)(J:J), IJUNK)
  572. 70           CONTINUE
  573. 72           NAME2(J) = 129
  574.              LENT = J - 1
  575.              RETURN
  576.            ENDIF
  577. 30      CONTINUE
  578.  
  579.         NRNAME = NRNAME + 1
  580.         IF(NRNAME.GT.MAXNAM) CALL ERROR('Too Many Long Names.')
  581.         LSTORE(NRNAME) = LTEMP
  582.  
  583. 60      CALL ZMESS('Type a replacement for the long name: '
  584.      +//LTEMP//'.', 2)
  585.         NEWLEN = ZGTCMD(NAME2, 0)
  586.  
  587. C  Check whether the proposed replacement is acceptable.
  588.         IF (LEGAL(NAME1,NAME2,NEWLEN) .EQ. -3) GO TO 60
  589.  
  590. C  Proposed replacement accepted.  Add to table of used names
  591. C  (in lower case) and to replacement tables (in original case).
  592.  
  593.         NAMCNT = NAMCNT + 1
  594.            DO 400 I = 1, 132-4
  595.               IF(NAME2(I) .EQ. 129) GO TO 410
  596.               TNAME2(I) = ZLOWER(NAME2(I))
  597. 400        CONTINUE
  598. 410     TNAME2(I) = 129
  599.         CALL SCOPY(TNAME2,1,NAMTAB(1,NAMCNT),1)
  600.  
  601.         DO 50 J=1,NEWLEN
  602.            SSTORE(NRNAME)(J:J) = ZCITOC(NAME2(J), CJUNK)
  603. 50      CONTINUE
  604.  
  605. C  Pad With Blanks
  606.        IF (J.LE.6) SSTORE(NRNAME)(J:) = ' '
  607. C  Return new LENGTH
  608.         LENT = NEWLEN
  609.  
  610.         END
  611.